home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / perl / 5.10.0 / Pod / Perldoc.pm < prev    next >
Encoding:
Text File  |  2009-06-26  |  54.3 KB  |  1,824 lines
  1.  
  2. require 5;
  3. use 5.006;  # we use some open(X, "<", $y) syntax 
  4. package Pod::Perldoc;
  5. use strict;
  6. use warnings;
  7. use Config '%Config';
  8.  
  9. use Fcntl;    # for sysopen
  10. use File::Spec::Functions qw(catfile catdir splitdir);
  11.  
  12. use vars qw($VERSION @Pagers $Bindir $Pod2man
  13.   $Temp_Files_Created $Temp_File_Lifetime
  14. );
  15. $VERSION = '3.14_02';
  16. #..........................................................................
  17.  
  18. BEGIN {  # Make a DEBUG constant very first thing...
  19.   unless(defined &DEBUG) {
  20.     if(($ENV{'PERLDOCDEBUG'} || '') =~ m/^(\d+)/) { # untaint
  21.       eval("sub DEBUG () {$1}");
  22.       die "WHAT? Couldn't eval-up a DEBUG constant!? $@" if $@;
  23.     } else {
  24.       *DEBUG = sub () {0};
  25.     }
  26.   }
  27. }
  28.  
  29. use Pod::Perldoc::GetOptsOO; # uses the DEBUG.
  30.  
  31. #..........................................................................
  32.  
  33. sub TRUE  () {1}
  34. sub FALSE () {return}
  35.  
  36. BEGIN {
  37.  *IS_VMS     = $^O eq 'VMS'     ? \&TRUE : \&FALSE unless defined &IS_VMS;
  38.  *IS_MSWin32 = $^O eq 'MSWin32' ? \&TRUE : \&FALSE unless defined &IS_MSWin32;
  39.  *IS_Dos     = $^O eq 'dos'     ? \&TRUE : \&FALSE unless defined &IS_Dos;
  40.  *IS_OS2     = $^O eq 'os2'     ? \&TRUE : \&FALSE unless defined &IS_OS2;
  41.  *IS_Cygwin  = $^O eq 'cygwin'  ? \&TRUE : \&FALSE unless defined &IS_Cygwin;
  42.  *IS_Linux   = $^O eq 'linux'   ? \&TRUE : \&FALSE unless defined &IS_Linux;
  43.  *IS_HPUX    = $^O =~ m/hpux/   ? \&TRUE : \&FALSE unless defined &IS_HPUX;
  44. }
  45.  
  46. $Temp_File_Lifetime ||= 60 * 60 * 24 * 5;
  47.   # If it's older than five days, it's quite unlikely
  48.   #  that anyone's still looking at it!!
  49.   # (Currently used only by the MSWin cleanup routine)
  50.  
  51.  
  52. #..........................................................................
  53. { my $pager = $Config{'pager'};
  54.   push @Pagers, $pager if -x (split /\s+/, $pager)[0] or IS_VMS;
  55. }
  56. $Bindir  = $Config{'scriptdirexp'};
  57. $Pod2man = "pod2man" . ( $Config{'versiononly'} ? $Config{'version'} : '' );
  58.  
  59. # End of class-init stuff
  60. #
  61. ###########################################################################
  62. #
  63. # Option accessors...
  64.  
  65. foreach my $subname (map "opt_$_", split '', q{mhlvriFfXqnTdUL}) {
  66.   no strict 'refs';
  67.   *$subname = do{ use strict 'refs';  sub () { shift->_elem($subname, @_) } };
  68. }
  69.  
  70. # And these are so that GetOptsOO knows they take options:
  71. sub opt_f_with { shift->_elem('opt_f', @_) }
  72. sub opt_q_with { shift->_elem('opt_q', @_) }
  73. sub opt_d_with { shift->_elem('opt_d', @_) }
  74. sub opt_L_with { shift->_elem('opt_L', @_) }
  75.  
  76. sub opt_w_with { # Specify an option for the formatter subclass
  77.   my($self, $value) = @_;
  78.   if($value =~ m/^([-_a-zA-Z][-_a-zA-Z0-9]*)(?:[=\:](.*?))?$/s) {
  79.     my $option = $1;
  80.     my $option_value = defined($2) ? $2 : "TRUE";
  81.     $option =~ tr/\-/_/s;  # tolerate "foo-bar" for "foo_bar"
  82.     $self->add_formatter_option( $option, $option_value );
  83.   } else {
  84.     warn "\"$value\" isn't a good formatter option name.  I'm ignoring it!\n";
  85.   }
  86.   return;
  87. }
  88.  
  89. sub opt_M_with { # specify formatter class name(s)
  90.   my($self, $classes) = @_;
  91.   return unless defined $classes and length $classes;
  92.   DEBUG > 4 and print "Considering new formatter classes -M$classes\n";
  93.   my @classes_to_add;
  94.   foreach my $classname (split m/[,;]+/s, $classes) {
  95.     next unless $classname =~ m/\S/;
  96.     if( $classname =~ m/^(\w+(::\w+)+)$/s ) {
  97.       # A mildly restrictive concept of what modulenames are valid.
  98.       push @classes_to_add, $1; # untaint
  99.     } else {
  100.       warn "\"$classname\" isn't a valid classname.  Ignoring.\n";
  101.     }
  102.   }
  103.   
  104.   unshift @{ $self->{'formatter_classes'} }, @classes_to_add;
  105.   
  106.   DEBUG > 3 and print(
  107.     "Adding @classes_to_add to the list of formatter classes, "
  108.     . "making them @{ $self->{'formatter_classes'} }.\n"
  109.   );
  110.   
  111.   return;
  112. }
  113.  
  114. sub opt_V { # report version and exit
  115.   print join '',
  116.     "Perldoc v$VERSION, under perl v$] for $^O",
  117.  
  118.     (defined(&Win32::BuildNumber) and defined &Win32::BuildNumber())
  119.      ? (" (win32 build ", &Win32::BuildNumber(), ")") : (),
  120.     
  121.     (chr(65) eq 'A') ? () : " (non-ASCII)",
  122.     
  123.     "\n",
  124.   ;
  125.   exit;
  126. }
  127.  
  128. sub opt_t { # choose plaintext as output format
  129.   my $self = shift;
  130.   $self->opt_o_with('text')  if @_ and $_[0];
  131.   return $self->_elem('opt_t', @_);
  132. }
  133.  
  134. sub opt_u { # choose raw pod as output format
  135.   my $self = shift;
  136.   $self->opt_o_with('pod')  if @_ and $_[0];
  137.   return $self->_elem('opt_u', @_);
  138. }
  139.  
  140. sub opt_n_with {
  141.   # choose man as the output format, and specify the proggy to run
  142.   my $self = shift;
  143.   $self->opt_o_with('man')  if @_ and $_[0];
  144.   $self->_elem('opt_n', @_);
  145. }
  146.  
  147. sub opt_o_with { # "o" for output format
  148.   my($self, $rest) = @_;
  149.   return unless defined $rest and length $rest;
  150.   if($rest =~ m/^(\w+)$/s) {
  151.     $rest = $1; #untaint
  152.   } else {
  153.     warn "\"$rest\" isn't a valid output format.  Skipping.\n";
  154.     return;
  155.   }
  156.   
  157.   $self->aside("Noting \"$rest\" as desired output format...\n");
  158.   
  159.   # Figure out what class(es) that could actually mean...
  160.   
  161.   my @classes;
  162.   foreach my $prefix ("Pod::Perldoc::To", "Pod::Simple::", "Pod::") {
  163.     # Messy but smart:
  164.     foreach my $stem (
  165.       $rest,  # Yes, try it first with the given capitalization
  166.       "\L$rest", "\L\u$rest", "\U$rest" # And then try variations
  167.  
  168.     ) {
  169.       push @classes, $prefix . $stem;
  170.       #print "Considering $prefix$stem\n";
  171.     }
  172.     
  173.     # Tidier, but misses too much:
  174.     #push @classes, $prefix . ucfirst(lc($rest));
  175.   }
  176.   $self->opt_M_with( join ";", @classes );
  177.   return;
  178. }
  179.  
  180. ###########################################################################
  181. # % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % %
  182.  
  183. sub run {  # to be called by the "perldoc" executable
  184.   my $class = shift;
  185.   if(DEBUG > 3) {
  186.     print "Parameters to $class\->run:\n";
  187.     my @x = @_;
  188.     while(@x) {
  189.       $x[1] = '<undef>'  unless defined $x[1];
  190.       $x[1] = "@{$x[1]}" if ref( $x[1] ) eq 'ARRAY';
  191.       print "  [$x[0]] => [$x[1]]\n";
  192.       splice @x,0,2;
  193.     }
  194.     print "\n";
  195.   }
  196.   return $class -> new(@_) -> process() || 0;
  197. }
  198.  
  199. # % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % %
  200. ###########################################################################
  201.  
  202. sub new {  # yeah, nothing fancy
  203.   my $class = shift;
  204.   my $new = bless {@_}, (ref($class) || $class);
  205.   DEBUG > 1 and print "New $class object $new\n";
  206.   $new->init();
  207.   $new;
  208. }
  209.  
  210. #..........................................................................
  211.  
  212. sub aside {  # If we're in -v or DEBUG mode, say this.
  213.   my $self = shift;
  214.   if( DEBUG or $self->opt_v ) {
  215.     my $out = join( '',
  216.       DEBUG ? do {
  217.         my $callsub = (caller(1))[3];
  218.         my $package = quotemeta(__PACKAGE__ . '::');
  219.         $callsub =~ s/^$package/'/os;
  220.          # the o is justified, as $package really won't change.
  221.         $callsub . ": ";
  222.       } : '',
  223.       @_,
  224.     );
  225.     if(DEBUG) { print $out } else { print STDERR $out }
  226.   }
  227.   return;
  228. }
  229.  
  230. #..........................................................................
  231.  
  232. sub usage {
  233.   my $self = shift;
  234.   warn "@_\n" if @_;
  235.   
  236.   # Erase evidence of previous errors (if any), so exit status is simple.
  237.   $! = 0;
  238.   
  239.   die <<EOF;
  240. perldoc [options] PageName|ModuleName|ProgramName...
  241. perldoc [options] -f BuiltinFunction
  242. perldoc [options] -q FAQRegex
  243.  
  244. Options:
  245.     -h   Display this help message
  246.     -V   report version
  247.     -r   Recursive search (slow)
  248.     -i   Ignore case
  249.     -t   Display pod using pod2text instead of pod2man and nroff
  250.              (-t is the default on win32 unless -n is specified)
  251.     -u   Display unformatted pod text
  252.     -m   Display module's file in its entirety
  253.     -n   Specify replacement for nroff
  254.     -l   Display the module's file name
  255.     -F   Arguments are file names, not modules
  256.     -v   Verbosely describe what's going on
  257.     -T   Send output to STDOUT without any pager
  258.     -d output_filename_to_send_to
  259.     -o output_format_name
  260.     -M FormatterModuleNameToUse
  261.     -w formatter_option:option_value
  262.     -L translation_code   Choose doc translation (if any)
  263.     -X   use index if present (looks for pod.idx at $Config{archlib})
  264.     -q   Search the text of questions (not answers) in perlfaq[1-9]
  265.  
  266. PageName|ModuleName...
  267.          is the name of a piece of documentation that you want to look at. You
  268.          may either give a descriptive name of the page (as in the case of
  269.          `perlfunc') the name of a module, either like `Term::Info' or like
  270.          `Term/Info', or the name of a program, like `perldoc'.
  271.  
  272. BuiltinFunction
  273.          is the name of a perl function.  Will extract documentation from
  274.          `perlfunc'.
  275.  
  276. FAQRegex
  277.          is a regex. Will search perlfaq[1-9] for and extract any
  278.          questions that match.
  279.  
  280. Any switches in the PERLDOC environment variable will be used before the
  281. command line arguments.  The optional pod index file contains a list of
  282. filenames, one per line.
  283.                                                        [Perldoc v$VERSION]
  284. EOF
  285.  
  286. }
  287.  
  288. #..........................................................................
  289.  
  290. sub usage_brief {
  291.   my $me = $0;        # Editing $0 is unportable
  292.  
  293.   $me =~ s,.*[/\\],,; # get basename
  294.   
  295.   die <<"EOUSAGE";
  296. Usage: $me [-h] [-V] [-r] [-i] [-v] [-t] [-u] [-m] [-n nroffer_program] [-l] [-T] [-d output_filename] [-o output_format] [-M FormatterModuleNameToUse] [-w formatter_option:option_value] [-L translation_code] [-F] [-X] PageName|ModuleName|ProgramName
  297.        $me -f PerlFunc
  298.        $me -q FAQKeywords
  299.  
  300. The -h option prints more help.  Also try "perldoc perldoc" to get
  301. acquainted with the system.                        [Perldoc v$VERSION]
  302. EOUSAGE
  303.  
  304. }
  305.  
  306. #..........................................................................
  307.  
  308. sub pagers { @{ shift->{'pagers'} } } 
  309.  
  310. #..........................................................................
  311.  
  312. sub _elem {  # handy scalar meta-accessor: shift->_elem("foo", @_)
  313.   if(@_ > 2) { return  $_[0]{ $_[1] } = $_[2]  }
  314.   else       { return  $_[0]{ $_[1] }          }
  315. }
  316. #..........................................................................
  317. ###########################################################################
  318. #
  319. # Init formatter switches, and start it off with __bindir and all that
  320. # other stuff that ToMan.pm needs.
  321. #
  322.  
  323. sub init {
  324.   my $self = shift;
  325.  
  326.   # Make sure creat()s are neither too much nor too little
  327.   eval { umask(0077) };   # doubtless someone has no mask
  328.  
  329.   $self->{'args'}              ||= \@ARGV;
  330.   $self->{'found'}             ||= [];
  331.   $self->{'temp_file_list'}    ||= [];
  332.   
  333.   
  334.   $self->{'target'} = undef;
  335.  
  336.   $self->init_formatter_class_list;
  337.  
  338.   $self->{'pagers' } = [@Pagers] unless exists $self->{'pagers'};
  339.   $self->{'bindir' } = $Bindir   unless exists $self->{'bindir'};
  340.   $self->{'pod2man'} = $Pod2man  unless exists $self->{'pod2man'};
  341.  
  342.   push @{ $self->{'formatter_switches'} = [] }, (
  343.    # Yeah, we could use a hashref, but maybe there's some class where options
  344.    # have to be ordered; so we'll use an arrayref.
  345.  
  346.      [ '__bindir'  => $self->{'bindir' } ],
  347.      [ '__pod2man' => $self->{'pod2man'} ],
  348.   );
  349.  
  350.   DEBUG > 3 and printf "Formatter switches now: [%s]\n",
  351.    join ' ', map "[@$_]", @{ $self->{'formatter_switches'} };
  352.  
  353.   $self->{'translators'} = [];
  354.   $self->{'extra_search_dirs'} = [];
  355.  
  356.   return;
  357. }
  358.  
  359. #..........................................................................
  360.  
  361. sub init_formatter_class_list {
  362.   my $self = shift;
  363.   $self->{'formatter_classes'} ||= [];
  364.  
  365.   # Remember, no switches have been read yet, when
  366.   # we've started this routine.
  367.  
  368.   $self->opt_M_with('Pod::Perldoc::ToPod');   # the always-there fallthru
  369.   $self->opt_o_with('text');
  370.   $self->opt_o_with('man') unless IS_MSWin32 || IS_Dos
  371.        || !($ENV{TERM} && (
  372.               ($ENV{TERM} || '') !~ /dumb|emacs|none|unknown/i
  373.            ));
  374.  
  375.   return;
  376. }
  377.  
  378. #..........................................................................
  379.  
  380. sub process {
  381.     # if this ever returns, its retval will be used for exit(RETVAL)
  382.  
  383.     my $self = shift;
  384.     DEBUG > 1 and print "  Beginning process.\n";
  385.     DEBUG > 1 and print "  Args: @{$self->{'args'}}\n\n";
  386.     if(DEBUG > 3) {
  387.         print "Object contents:\n";
  388.         my @x = %$self;
  389.         while(@x) {
  390.             $x[1] = '<undef>'  unless defined $x[1];
  391.             $x[1] = "@{$x[1]}" if ref( $x[1] ) eq 'ARRAY';
  392.             print "  [$x[0]] => [$x[1]]\n";
  393.             splice @x,0,2;
  394.         }
  395.         print "\n";
  396.     }
  397.  
  398.     # TODO: make it deal with being invoked as various different things
  399.     #  such as perlfaq".
  400.   
  401.     return $self->usage_brief  unless  @{ $self->{'args'} };
  402.     $self->pagers_guessing;
  403.     $self->options_reading;
  404.     $self->aside(sprintf "$0 => %s v%s\n", ref($self), $self->VERSION);
  405.     $self->drop_privs_maybe;
  406.     $self->options_processing;
  407.     
  408.     # Hm, we have @pages and @found, but we only really act on one
  409.     # file per call, with the exception of the opt_q hack, and with
  410.     # -l things
  411.  
  412.     $self->aside("\n");
  413.  
  414.     my @pages;
  415.     $self->{'pages'} = \@pages;
  416.     if(    $self->opt_f) { @pages = ("perlfunc")               }
  417.     elsif( $self->opt_q) { @pages = ("perlfaq1" .. "perlfaq9") }
  418.     else                 { @pages = @{$self->{'args'}};
  419.                            # @pages = __FILE__
  420.                            #  if @pages == 1 and $pages[0] eq 'perldoc';
  421.                          }
  422.  
  423.     return $self->usage_brief  unless  @pages;
  424.  
  425.     $self->find_good_formatter_class();
  426.     $self->formatter_sanity_check();
  427.  
  428.     $self->maybe_diddle_INC();
  429.       # for when we're apparently in a module or extension directory
  430.     
  431.     my @found = $self->grand_search_init(\@pages);
  432.     exit (IS_VMS ? 98962 : 1) unless @found;
  433.     
  434.     if ($self->opt_l) {
  435.         DEBUG and print "We're in -l mode, so byebye after this:\n";
  436.         print join("\n", @found), "\n";
  437.         return;
  438.     }
  439.  
  440.     $self->tweak_found_pathnames(\@found);
  441.     $self->assert_closing_stdout;
  442.     return $self->page_module_file(@found)  if  $self->opt_m;
  443.     DEBUG > 2 and print "Found: [@found]\n";
  444.  
  445.     return $self->render_and_page(\@found);
  446. }
  447.  
  448. #..........................................................................
  449. {
  450.  
  451. my( %class_seen, %class_loaded );
  452. sub find_good_formatter_class {
  453.   my $self = $_[0];
  454.   my @class_list = @{ $self->{'formatter_classes'} || [] };
  455.   die "WHAT?  Nothing in the formatter class list!?" unless @class_list;
  456.   
  457.   my $good_class_found;
  458.   foreach my $c (@class_list) {
  459.     DEBUG > 4 and print "Trying to load $c...\n";
  460.     if($class_loaded{$c}) {
  461.       DEBUG > 4 and print "OK, the already-loaded $c it is!\n";
  462.       $good_class_found = $c;
  463.       last;
  464.     }
  465.     
  466.     if($class_seen{$c}) {
  467.       DEBUG > 4 and print
  468.        "I've tried $c before, and it's no good.  Skipping.\n";
  469.       next;
  470.     }
  471.     
  472.     $class_seen{$c} = 1;
  473.     
  474.     if( $c->can('parse_from_file') ) {
  475.       DEBUG > 4 and print
  476.        "Interesting, the formatter class $c is already loaded!\n";
  477.       
  478.     } elsif(
  479.       (IS_VMS or IS_MSWin32 or IS_Dos or IS_OS2)
  480.        # the alway case-insensitive fs's
  481.       and $class_seen{lc("~$c")}++
  482.     ) {
  483.       DEBUG > 4 and print
  484.        "We already used something quite like \"\L$c\E\", so no point using $c\n";
  485.       # This avoids redefining the package.
  486.     } else {
  487.       DEBUG > 4 and print "Trying to eval 'require $c'...\n";
  488.  
  489.       local $^W = $^W;
  490.       if(DEBUG() or $self->opt_v) {
  491.         # feh, let 'em see it
  492.       } else {
  493.         $^W = 0;
  494.         # The average user just has no reason to be seeing
  495.         #  $^W-suppressable warnings from the the require!
  496.       }
  497.  
  498.       eval "require $c";
  499.       if($@) {
  500.         DEBUG > 4 and print "Couldn't load $c: $!\n";
  501.         next;
  502.       }
  503.     }
  504.     
  505.     if( $c->can('parse_from_file') ) {
  506.       DEBUG > 4 and print "Settling on $c\n";
  507.       my $v = $c->VERSION;
  508.       $v = ( defined $v and length $v ) ? " version $v" : '';
  509.       $self->aside("Formatter class $c$v successfully loaded!\n");
  510.       $good_class_found = $c;
  511.       last;
  512.     } else {
  513.       DEBUG > 4 and print "Class $c isn't a formatter?!  Skipping.\n";
  514.     }
  515.   }
  516.   
  517.   die "Can't find any loadable formatter class in @class_list?!\nAborting"
  518.     unless $good_class_found;
  519.   
  520.   $self->{'formatter_class'} = $good_class_found;
  521.   $self->aside("Will format with the class $good_class_found\n");
  522.   
  523.   return;
  524. }
  525.  
  526. }
  527. #..........................................................................
  528.  
  529. sub formatter_sanity_check {
  530.   my $self = shift;
  531.   my $formatter_class = $self->{'formatter_class'}
  532.    || die "NO FORMATTER CLASS YET!?";
  533.   
  534.   if(!$self->opt_T # so -T can FORCE sending to STDOUT
  535.     and $formatter_class->can('is_pageable')
  536.     and !$formatter_class->is_pageable
  537.     and !$formatter_class->can('page_for_perldoc')
  538.   ) {
  539.     my $ext =
  540.      ($formatter_class->can('output_extension')
  541.        && $formatter_class->output_extension
  542.      ) || '';
  543.     $ext = ".$ext" if length $ext;
  544.     
  545.     die
  546.        "When using Perldoc to format with $formatter_class, you have to\n"
  547.      . "specify -T or -dsomefile$ext\n"
  548.      . "See `perldoc perldoc' for more information on those switches.\n"
  549.     ;
  550.   }
  551. }
  552.  
  553. #..........................................................................
  554.  
  555. sub render_and_page {
  556.     my($self, $found_list) = @_;
  557.     
  558.     $self->maybe_generate_dynamic_pod($found_list);
  559.  
  560.     my($out, $formatter) = $self->render_findings($found_list);
  561.     
  562.     if($self->opt_d) {
  563.       printf "Perldoc (%s) output saved to %s\n",
  564.         $self->{'formatter_class'} || ref($self),
  565.         $out;
  566.       print "But notice that it's 0 bytes long!\n" unless -s $out;
  567.       
  568.       
  569.     } elsif(  # Allow the formatter to "page" itself, if it wants.
  570.       $formatter->can('page_for_perldoc')
  571.       and do {
  572.         $self->aside("Going to call $formatter\->page_for_perldoc(\"$out\")\n");
  573.         if( $formatter->page_for_perldoc($out, $self) ) {
  574.           $self->aside("page_for_perldoc returned true, so NOT paging with $self.\n");
  575.           1;
  576.         } else {
  577.           $self->aside("page_for_perldoc returned false, so paging with $self instead.\n");
  578.           '';
  579.         }
  580.       }
  581.     ) {
  582.       # Do nothing, since the formatter has "paged" it for itself.
  583.     
  584.     } else {
  585.       # Page it normally (internally)
  586.       
  587.       if( -s $out ) {  # Usual case:
  588.         $self->page($out, $self->{'output_to_stdout'}, $self->pagers);
  589.         
  590.       } else {
  591.         # Odd case:
  592.         $self->aside("Skipping $out (from $$found_list[0] "
  593.          . "via $$self{'formatter_class'}) as it is 0-length.\n");
  594.          
  595.         push @{ $self->{'temp_file_list'} }, $out;
  596.         $self->unlink_if_temp_file($out);
  597.       }
  598.     }
  599.     
  600.     $self->after_rendering();  # any extra cleanup or whatever
  601.     
  602.     return;
  603. }
  604.  
  605. #..........................................................................
  606.  
  607. sub options_reading {
  608.     my $self = shift;
  609.     
  610.     if( defined $ENV{"PERLDOC"} and length $ENV{"PERLDOC"} ) {
  611.       require Text::ParseWords;
  612.       $self->aside("Noting env PERLDOC setting of $ENV{'PERLDOC'}\n");
  613.       # Yes, appends to the beginning
  614.       unshift @{ $self->{'args'} },
  615.         Text::ParseWords::shellwords( $ENV{"PERLDOC"} )
  616.       ;
  617.       DEBUG > 1 and print "  Args now: @{$self->{'args'}}\n\n";
  618.     } else {
  619.       DEBUG > 1 and print "  Okay, no PERLDOC setting in ENV.\n";
  620.     }
  621.  
  622.     DEBUG > 1
  623.      and print "  Args right before switch processing: @{$self->{'args'}}\n";
  624.  
  625.     Pod::Perldoc::GetOptsOO::getopts( $self, $self->{'args'}, 'YES' )
  626.      or return $self->usage;
  627.  
  628.     DEBUG > 1
  629.      and print "  Args after switch processing: @{$self->{'args'}}\n";
  630.  
  631.     return $self->usage if $self->opt_h;
  632.   
  633.     return;
  634. }
  635.  
  636. #..........................................................................
  637.  
  638. sub options_processing {
  639.     my $self = shift;
  640.     
  641.     if ($self->opt_X) {
  642.         my $podidx = "$Config{'archlib'}/pod.idx";
  643.         $podidx = "" unless -f $podidx && -r _ && -M _ <= 7;
  644.         $self->{'podidx'} = $podidx;
  645.     }
  646.  
  647.     $self->{'output_to_stdout'} = 1  if  $self->opt_T or ! -t STDOUT;
  648.  
  649.     $self->options_sanity;
  650.  
  651.     $self->opt_n("nroff") unless $self->opt_n;
  652.     $self->add_formatter_option( '__nroffer' => $self->opt_n );
  653.  
  654.     # Adjust for using translation packages
  655.     $self->add_translator($self->opt_L) if $self->opt_L;
  656.  
  657.     return;
  658. }
  659.  
  660. #..........................................................................
  661.  
  662. sub options_sanity {
  663.     my $self = shift;
  664.  
  665.     # The opts-counting stuff interacts quite badly with
  666.     # the $ENV{"PERLDOC"} stuff.  I.e., if I have $ENV{"PERLDOC"}
  667.     # set to -t, and I specify -u on the command line, I don't want
  668.     # to be hectored at that -u and -t don't make sense together.
  669.  
  670.     #my $opts = grep $_ && 1, # yes, the count of the set ones
  671.     #  $self->opt_t, $self->opt_u, $self->opt_m, $self->opt_l
  672.     #;
  673.     #
  674.     #$self->usage("only one of -t, -u, -m or -l") if $opts > 1;
  675.     
  676.     
  677.     # Any sanity-checking need doing here?
  678.     
  679.     # But does not make sense to set either -f or -q in $ENV{"PERLDOC"} 
  680.     if( $self->opt_f or $self->opt_q ) { 
  681.     $self->usage("Only one of -f -or -q") if $self->opt_f and $self->opt_q;
  682.     warn 
  683.         "Perldoc is only really meant for reading one word at a time.\n",
  684.         "So these parameters are being ignored: ",
  685.         join(' ', @{$self->{'args'}}),
  686.         "\n"
  687.         if @{$self->{'args'}}
  688.     }
  689.     return;
  690. }
  691.  
  692. #..........................................................................
  693.  
  694. sub grand_search_init {
  695.     my($self, $pages, @found) = @_;
  696.  
  697.     foreach (@$pages) {
  698.         if ($self->{'podidx'} && open(PODIDX, $self->{'podidx'})) {
  699.             my $searchfor = catfile split '::', $_;
  700.             $self->aside( "Searching for '$searchfor' in $self->{'podidx'}\n" );
  701.             local $_;
  702.             while (<PODIDX>) {
  703.                 chomp;
  704.                 push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?\z,i;
  705.             }
  706.             close(PODIDX)            or die "Can't close $$self{'podidx'}: $!";
  707.             next;
  708.         }
  709.  
  710.         $self->aside( "Searching for $_\n" );
  711.  
  712.         if ($self->opt_F) {
  713.             next unless -r;
  714.             push @found, $_ if $self->opt_m or $self->containspod($_);
  715.             next;
  716.         }
  717.  
  718.         my @searchdirs;
  719.  
  720.         # prepend extra search directories (including language specific)
  721.         push @searchdirs, @{ $self->{'extra_search_dirs'} };
  722.  
  723.         # We must look both in @INC for library modules and in $bindir
  724.         # for executables, like h2xs or perldoc itself.
  725.         push @searchdirs, ($self->{'bindir'}, @INC);
  726.         unless ($self->opt_m) {
  727.             if (IS_VMS) {
  728.                 my($i,$trn);
  729.                 for ($i = 0; $trn = $ENV{'DCL$PATH;'.$i}; $i++) {
  730.                     push(@searchdirs,$trn);
  731.                 }
  732.                 push(@searchdirs,'perl_root:[lib.pod]')  # installed pods
  733.             }
  734.             else {
  735.                 push(@searchdirs, grep(-d, split($Config{path_sep},
  736.                                                  $ENV{'PATH'})));
  737.             }
  738.         }
  739.         my @files = $self->searchfor(0,$_,@searchdirs);
  740.         if (@files) {
  741.             $self->aside( "Found as @files\n" );
  742.         }
  743.         else {
  744.             # no match, try recursive search
  745.             @searchdirs = grep(!/^\.\z/s,@INC);
  746.             @files= $self->searchfor(1,$_,@searchdirs) if $self->opt_r;
  747.             if (@files) {
  748.                 $self->aside( "Loosely found as @files\n" );
  749.             }
  750.             else {
  751.                 print STDERR "No " .
  752.                     ($self->opt_m ? "module" : "documentation") . " found for \"$_\".\n";
  753.                 if ( @{ $self->{'found'} } ) {
  754.                     print STDERR "However, try\n";
  755.                     for my $dir (@{ $self->{'found'} }) {
  756.                         opendir(DIR, $dir) or die "opendir $dir: $!";
  757.                         while (my $file = readdir(DIR)) {
  758.                             next if ($file =~ /^\./s);
  759.                             $file =~ s/\.(pm|pod)\z//;  # XXX: badfs
  760.                             print STDERR "\tperldoc $_\::$file\n";
  761.                         }
  762.                         closedir(DIR)    or die "closedir $dir: $!";
  763.                     }
  764.                 }
  765.             }
  766.         }
  767.         push(@found,@files);
  768.     }
  769.     return @found;
  770. }
  771.  
  772. #..........................................................................
  773.  
  774. sub maybe_generate_dynamic_pod {
  775.     my($self, $found_things) = @_;
  776.     my @dynamic_pod;
  777.     
  778.     $self->search_perlfunc($found_things, \@dynamic_pod)  if  $self->opt_f;
  779.     
  780.     $self->search_perlfaqs($found_things, \@dynamic_pod)  if  $self->opt_q;
  781.  
  782.     if( ! $self->opt_f and ! $self->opt_q ) {
  783.         DEBUG > 4 and print "That's a non-dynamic pod search.\n";
  784.     } elsif ( @dynamic_pod ) {
  785.         $self->aside("Hm, I found some Pod from that search!\n");
  786.         my ($buffd, $buffer) = $self->new_tempfile('pod', 'dyn');
  787.         
  788.         push @{ $self->{'temp_file_list'} }, $buffer;
  789.          # I.e., it MIGHT be deleted at the end.
  790.         
  791.     my $in_list = $self->opt_f;
  792.  
  793.         print $buffd "=over 8\n\n" if $in_list;
  794.         print $buffd @dynamic_pod  or die "Can't print $buffer: $!";
  795.         print $buffd "=back\n"     if $in_list;
  796.  
  797.         close $buffd        or die "Can't close $buffer: $!";
  798.         
  799.         @$found_things = $buffer;
  800.           # Yes, so found_things never has more than one thing in
  801.           #  it, by time we leave here
  802.         
  803.         $self->add_formatter_option('__filter_nroff' => 1);
  804.  
  805.     } else {
  806.         @$found_things = ();
  807.         $self->aside("I found no Pod from that search!\n");
  808.     }
  809.  
  810.     return;
  811. }
  812.  
  813. #..........................................................................
  814.  
  815. sub add_formatter_option { # $self->add_formatter_option('key' => 'value');
  816.   my $self = shift;
  817.   push @{ $self->{'formatter_switches'} }, [ @_ ] if @_;
  818.  
  819.   DEBUG > 3 and printf "Formatter switches now: [%s]\n",
  820.    join ' ', map "[@$_]", @{ $self->{'formatter_switches'} };
  821.   
  822.   return;
  823. }
  824.  
  825. #.........................................................................
  826.  
  827. sub pod_dirs { # @dirs = pod_dirs($translator);
  828.     my $tr = shift;
  829.     return $tr->pod_dirs if $tr->can('pod_dirs');
  830.     
  831.     my $mod = ref $tr || $tr;
  832.     $mod =~ s|::|/|g;
  833.     $mod .= '.pm';
  834.  
  835.     my $dir = $INC{$mod};
  836.     $dir =~ s/\.pm\z//;
  837.     return $dir;
  838. }
  839.  
  840. #.........................................................................
  841.  
  842. sub add_translator { # $self->add_translator($lang);
  843.     my $self = shift;
  844.     for my $lang (@_) {
  845.         my $pack = 'POD2::' . uc($lang);
  846.         eval "require $pack";
  847.         if ( $@ ) {
  848.             # XXX warn: non-installed translator package
  849.         } else {
  850.             push @{ $self->{'translators'} }, $pack;
  851.             push @{ $self->{'extra_search_dirs'} }, pod_dirs($pack);
  852.             # XXX DEBUG
  853.         }
  854.     }
  855.     return;
  856. }
  857.  
  858. #..........................................................................
  859.  
  860. sub search_perlfunc {
  861.     my($self, $found_things, $pod) = @_;
  862.  
  863.     DEBUG > 2 and print "Search: @$found_things\n";
  864.  
  865.     my $perlfunc = shift @$found_things;
  866.     open(PFUNC, "<", $perlfunc)               # "Funk is its own reward"
  867.         or die("Can't open $perlfunc: $!");
  868.  
  869.     # Functions like -r, -e, etc. are listed under `-X'.
  870.     my $search_re = ($self->opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/)
  871.                         ? '(?:I<)?-X' : quotemeta($self->opt_f) ;
  872.  
  873.     DEBUG > 2 and
  874.      print "Going to perlfunc-scan for $search_re in $perlfunc\n";
  875.  
  876.     my $re = 'Alphabetical Listing of Perl Functions';
  877.     if ( $self->opt_L ) {
  878.         my $tr = $self->{'translators'}->[0];
  879.         $re =  $tr->search_perlfunc_re if $tr->can('search_perlfunc_re');
  880.     }
  881.  
  882.     # Skip introduction
  883.     local $_;
  884.     while (<PFUNC>) {
  885.         last if /^=head2 $re/;
  886.     }
  887.  
  888.     # Look for our function
  889.     my $found = 0;
  890.     my $inlist = 0;
  891.     while (<PFUNC>) {  # "The Mothership Connection is here!"
  892.         if ( m/^=item\s+$search_re\b/ )  {
  893.             $found = 1;
  894.         }
  895.         elsif (/^=item/) {
  896.             last if $found > 1 and not $inlist;
  897.         }
  898.         next unless $found;
  899.         if (/^=over/) {
  900.             ++$inlist;
  901.         }
  902.         elsif (/^=back/) {
  903.             --$inlist;
  904.         }
  905.         push @$pod, $_;
  906.         ++$found if /^\w/;        # found descriptive text
  907.     }
  908.     if (!@$pod) {
  909.         die sprintf
  910.           "No documentation for perl function `%s' found\n",
  911.           $self->opt_f
  912.         ;
  913.     }
  914.     close PFUNC                or die "Can't open $perlfunc: $!";
  915.  
  916.     return;
  917. }
  918.  
  919. #..........................................................................
  920.  
  921. sub search_perlfaqs {
  922.     my( $self, $found_things, $pod) = @_;
  923.  
  924.     my $found = 0;
  925.     my %found_in;
  926.     my $search_key = $self->opt_q;
  927.     
  928.     my $rx = eval { qr/$search_key/ }
  929.      or die <<EOD;
  930. Invalid regular expression '$search_key' given as -q pattern:
  931. $@
  932. Did you mean \\Q$search_key ?
  933.  
  934. EOD
  935.  
  936.     local $_;
  937.     foreach my $file (@$found_things) {
  938.         die "invalid file spec: $!" if $file =~ /[<>|]/;
  939.         open(INFAQ, "<", $file)  # XXX 5.6ism
  940.          or die "Can't read-open $file: $!\nAborting";
  941.         while (<INFAQ>) {
  942.             if ( m/^=head2\s+.*(?:$search_key)/i ) {
  943.                 $found = 1;
  944.                 push @$pod, "=head1 Found in $file\n\n" unless $found_in{$file}++;
  945.             }
  946.             elsif (/^=head[12]/) {
  947.                 $found = 0;
  948.             }
  949.             next unless $found;
  950.             push @$pod, $_;
  951.         }
  952.         close(INFAQ);
  953.     }
  954.     die("No documentation for perl FAQ keyword `$search_key' found\n")
  955.      unless @$pod;
  956.  
  957.     return;
  958. }
  959.  
  960.  
  961. #..........................................................................
  962.  
  963. sub render_findings {
  964.   # Return the filename to open
  965.  
  966.   my($self, $found_things) = @_;
  967.  
  968.   my $formatter_class = $self->{'formatter_class'}
  969.    || die "No formatter class set!?";
  970.   my $formatter = $formatter_class->can('new')
  971.     ? $formatter_class->new
  972.     : $formatter_class
  973.   ;
  974.  
  975.   if(! @$found_things) {
  976.     die "Nothing found?!";
  977.     # should have been caught before here
  978.   } elsif(@$found_things > 1) {
  979.     warn 
  980.      "Perldoc is only really meant for reading one document at a time.\n",
  981.      "So these parameters are being ignored: ",
  982.      join(' ', @$found_things[1 .. $#$found_things] ),
  983.      "\n"
  984.   }
  985.  
  986.   my $file = $found_things->[0];
  987.   
  988.   DEBUG > 3 and printf "Formatter switches now: [%s]\n",
  989.    join ' ', map "[@$_]", @{ $self->{'formatter_switches'} };
  990.  
  991.   # Set formatter options:
  992.   if( ref $formatter ) {
  993.     foreach my $f (@{ $self->{'formatter_switches'} || [] }) {
  994.       my($switch, $value, $silent_fail) = @$f;
  995.       if( $formatter->can($switch) ) {
  996.         eval { $formatter->$switch( defined($value) ? $value : () ) };
  997.         warn "Got an error when setting $formatter_class\->$switch:\n$@\n"
  998.          if $@;
  999.       } else {
  1000.         if( $silent_fail or $switch =~ m/^__/s ) {
  1001.           DEBUG > 2 and print "Formatter $formatter_class doesn't support $switch\n";
  1002.         } else {
  1003.           warn "$formatter_class doesn't recognize the $switch switch.\n";
  1004.         }
  1005.       }
  1006.     }
  1007.   }
  1008.   
  1009.   $self->{'output_is_binary'} =
  1010.     $formatter->can('write_with_binmode') && $formatter->write_with_binmode;
  1011.  
  1012.   my ($out_fh, $out) = $self->new_output_file(
  1013.     ( $formatter->can('output_extension') && $formatter->output_extension )
  1014.      || undef,
  1015.     $self->useful_filename_bit,
  1016.   );
  1017.  
  1018.   # Now, finally, do the formatting!
  1019.   {
  1020.     local $^W = $^W;
  1021.     if(DEBUG() or $self->opt_v) {
  1022.       # feh, let 'em see it
  1023.     } else {
  1024.       $^W = 0;
  1025.       # The average user just has no reason to be seeing
  1026.       #  $^W-suppressable warnings from the formatting!
  1027.     }
  1028.           
  1029.     eval {  $formatter->parse_from_file( $file, $out_fh )  };
  1030.   }
  1031.   
  1032.   warn "Error while formatting with $formatter_class:\n $@\n" if $@;
  1033.   DEBUG > 2 and print "Back from formatting with $formatter_class\n";
  1034.  
  1035.   close $out_fh 
  1036.    or warn "Can't close $out: $!\n(Did $formatter already close it?)";
  1037.   sleep 0; sleep 0; sleep 0;
  1038.    # Give the system a few timeslices to meditate on the fact
  1039.    # that the output file does in fact exist and is closed.
  1040.   
  1041.   $self->unlink_if_temp_file($file);
  1042.  
  1043.   unless( -s $out ) {
  1044.     if( $formatter->can( 'if_zero_length' ) ) {
  1045.       # Basically this is just a hook for Pod::Simple::Checker; since
  1046.       # what other class could /happily/ format an input file with Pod
  1047.       # as a 0-length output file?
  1048.       $formatter->if_zero_length( $file, $out, $out_fh );
  1049.     } else {
  1050.       warn "Got a 0-length file from $$found_things[0] via $formatter_class!?\n"
  1051.     }
  1052.   }
  1053.  
  1054.   DEBUG and print "Finished writing to $out.\n";
  1055.   return($out, $formatter) if wantarray;
  1056.   return $out;
  1057. }
  1058.  
  1059. #..........................................................................
  1060.  
  1061. sub unlink_if_temp_file {
  1062.   # Unlink the specified file IFF it's in the list of temp files.
  1063.   # Really only used in the case of -f / -q things when we can
  1064.   #  throw away the dynamically generated source pod file once
  1065.   #  we've formatted it.
  1066.   #
  1067.   my($self, $file) = @_;
  1068.   return unless defined $file and length $file;
  1069.   
  1070.   my $temp_file_list = $self->{'temp_file_list'} || return;
  1071.   if(grep $_ eq $file, @$temp_file_list) {
  1072.     $self->aside("Unlinking $file\n");
  1073.     unlink($file) or warn "Odd, couldn't unlink $file: $!";
  1074.   } else {
  1075.     DEBUG > 1 and print "$file isn't a temp file, so not unlinking.\n";
  1076.   }
  1077.   return;
  1078. }
  1079.  
  1080. #..........................................................................
  1081.  
  1082. sub MSWin_temp_cleanup {
  1083.  
  1084.   # Nothing particularly MSWin-specific in here, but I don't know if any
  1085.   # other OS needs its temp dir policed like MSWin does!
  1086.  
  1087.   my $self = shift;
  1088.  
  1089.   my $tempdir = $ENV{'TEMP'};
  1090.   return unless defined $tempdir and length $tempdir
  1091.    and -e $tempdir and -d _ and -w _;
  1092.  
  1093.   $self->aside(
  1094.    "Considering whether any old files of mine in $tempdir need unlinking.\n"
  1095.   );
  1096.  
  1097.   opendir(TMPDIR, $tempdir) || return;
  1098.   my @to_unlink;
  1099.   
  1100.   my $limit = time() - $Temp_File_Lifetime;
  1101.   
  1102.   DEBUG > 5 and printf "Looking for things pre-dating %s (%x)\n",
  1103.    ($limit) x 2;
  1104.   
  1105.   my $filespec;
  1106.   
  1107.   while(defined($filespec = readdir(TMPDIR))) {
  1108.     if(
  1109.      $filespec =~ m{^perldoc_[a-zA-Z0-9]+_T([a-fA-F0-9]{7,})_[a-fA-F0-9]{3,}}s
  1110.     ) {
  1111.       if( hex($1) < $limit ) {
  1112.         push @to_unlink, "$tempdir/$filespec";
  1113.         $self->aside( "Will unlink my old temp file $to_unlink[-1]\n" );
  1114.       } else {
  1115.         DEBUG > 5 and
  1116.          printf "  $tempdir/$filespec is too recent (after %x)\n", $limit;
  1117.       }
  1118.     } else {
  1119.       DEBUG > 5 and
  1120.        print "  $tempdir/$filespec doesn't look like a perldoc temp file.\n";
  1121.     }
  1122.   }
  1123.   closedir(TMPDIR);
  1124.   $self->aside(sprintf "Unlinked %s items of mine in %s\n",
  1125.     scalar(unlink(@to_unlink)),
  1126.     $tempdir
  1127.   );
  1128.   return;
  1129. }
  1130.  
  1131. #  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .
  1132.  
  1133. sub MSWin_perldoc_tempfile {
  1134.   my($self, $suffix, $infix) = @_;
  1135.  
  1136.   my $tempdir = $ENV{'TEMP'};
  1137.   return unless defined $tempdir and length $tempdir
  1138.    and -e $tempdir and -d _ and -w _;
  1139.  
  1140.   my $spec;
  1141.   
  1142.   do {
  1143.     $spec = sprintf "%s\\perldoc_%s_T%x_%x%02x.%s", # used also in MSWin_temp_cleanup
  1144.       # Yes, we embed the create-time in the filename!
  1145.       $tempdir,
  1146.       $infix || 'x',
  1147.       time(),
  1148.       $$,
  1149.       defined( &Win32::GetTickCount )
  1150.         ? (Win32::GetTickCount() & 0xff)
  1151.         : int(rand 256)
  1152.        # Under MSWin, $$ values get reused quickly!  So if we ran
  1153.        # perldoc foo and then perldoc bar before there was time for
  1154.        # time() to increment time."_$$" would likely be the same
  1155.        # for each process!  So we tack on the tick count's lower
  1156.        # bits (or, in a pinch, rand)
  1157.       ,
  1158.       $suffix || 'txt';
  1159.     ;
  1160.   } while( -e $spec );
  1161.  
  1162.   my $counter = 0;
  1163.   
  1164.   while($counter < 50) {
  1165.     my $fh;
  1166.     # If we are running before perl5.6.0, we can't autovivify
  1167.     if ($] < 5.006) {
  1168.       require Symbol;
  1169.       $fh = Symbol::gensym();
  1170.     }
  1171.     DEBUG > 3 and print "About to try making temp file $spec\n";
  1172.     return($fh, $spec) if open($fh, ">", $spec);    # XXX 5.6ism
  1173.     $self->aside("Can't create temp file $spec: $!\n");
  1174.   }
  1175.  
  1176.   $self->aside("Giving up on making a temp file!\n");
  1177.   die "Can't make a tempfile!?";
  1178. }
  1179.  
  1180. #..........................................................................
  1181.  
  1182.  
  1183. sub after_rendering {
  1184.   my $self = $_[0];
  1185.   $self->after_rendering_VMS     if IS_VMS;
  1186.   $self->after_rendering_MSWin32 if IS_MSWin32;
  1187.   $self->after_rendering_Dos     if IS_Dos;
  1188.   $self->after_rendering_OS2     if IS_OS2;
  1189.   return;
  1190. }
  1191.  
  1192. sub after_rendering_VMS      { return }
  1193. sub after_rendering_Dos      { return }
  1194. sub after_rendering_OS2      { return }
  1195.  
  1196. sub after_rendering_MSWin32  {
  1197.   shift->MSWin_temp_cleanup() if $Temp_Files_Created;
  1198. }
  1199.  
  1200. #..........................................................................
  1201. #    :    :    :    :    :    :    :    :    :
  1202. #..........................................................................
  1203.  
  1204.  
  1205. sub minus_f_nocase {   # i.e., do like -f, but without regard to case
  1206.  
  1207.      my($self, $dir, $file) = @_;
  1208.      my $path = catfile($dir,$file);
  1209.      return $path if -f $path and -r _;
  1210.  
  1211.      if(!$self->opt_i
  1212.         or IS_VMS or IS_MSWin32
  1213.         or IS_Dos or IS_OS2
  1214.      ) {
  1215.         # On a case-forgiving file system, or if case is important,
  1216.     #  that is it, all we can do.
  1217.     warn "Ignored $path: unreadable\n" if -f _;
  1218.     return '';
  1219.      }
  1220.      
  1221.      local *DIR;
  1222.      my @p = ($dir);
  1223.      my($p,$cip);
  1224.      foreach $p (splitdir $file){
  1225.     my $try = catfile @p, $p;
  1226.         $self->aside("Scrutinizing $try...\n");
  1227.     stat $try;
  1228.      if (-d _) {
  1229.          push @p, $p;
  1230.         if ( $p eq $self->{'target'} ) {
  1231.         my $tmp_path = catfile @p;
  1232.         my $path_f = 0;
  1233.         for (@{ $self->{'found'} }) {
  1234.             $path_f = 1 if $_ eq $tmp_path;
  1235.         }
  1236.         push (@{ $self->{'found'} }, $tmp_path) unless $path_f;
  1237.         $self->aside( "Found as $tmp_path but directory\n" );
  1238.         }
  1239.      }
  1240.     elsif (-f _ && -r _) {
  1241.          return $try;
  1242.      }
  1243.     elsif (-f _) {
  1244.         warn "Ignored $try: unreadable\n";
  1245.      }
  1246.     elsif (-d catdir(@p)) {  # at least we see the containing directory!
  1247.          my $found = 0;
  1248.          my $lcp = lc $p;
  1249.          my $p_dirspec = catdir(@p);
  1250.          opendir DIR, $p_dirspec  or die "opendir $p_dirspec: $!";
  1251.          while(defined( $cip = readdir(DIR) )) {
  1252.          if (lc $cip eq $lcp){
  1253.              $found++;
  1254.              last; # XXX stop at the first? what if there's others?
  1255.          }
  1256.          }
  1257.          closedir DIR  or die "closedir $p_dirspec: $!";
  1258.          return "" unless $found;
  1259.  
  1260.          push @p, $cip;
  1261.          my $p_filespec = catfile(@p);
  1262.          return $p_filespec if -f $p_filespec and -r _;
  1263.         warn "Ignored $p_filespec: unreadable\n" if -f _;
  1264.      }
  1265.      }
  1266.      return "";
  1267. }
  1268.  
  1269. #..........................................................................
  1270.  
  1271. sub pagers_guessing {
  1272.     my $self = shift;
  1273.  
  1274.     my @pagers;
  1275.     push @pagers, $self->pagers;
  1276.     $self->{'pagers'} = \@pagers;
  1277.  
  1278.     if (IS_MSWin32) {
  1279.         push @pagers, qw( more< less notepad );
  1280.         unshift @pagers, $ENV{PAGER}  if $ENV{PAGER};
  1281.     }
  1282.     elsif (IS_VMS) {
  1283.         push @pagers, qw( most more less type/page );
  1284.     }
  1285.     elsif (IS_Dos) {
  1286.         push @pagers, qw( less.exe more.com< );
  1287.         unshift @pagers, $ENV{PAGER}  if $ENV{PAGER};
  1288.     }
  1289.     else {
  1290.         if (IS_OS2) {
  1291.           unshift @pagers, 'less', 'cmd /c more <';
  1292.         }
  1293.         push @pagers, qw( more less pg view cat );
  1294.         unshift @pagers, $ENV{PAGER}  if $ENV{PAGER};
  1295.     }
  1296.  
  1297.     if (IS_Cygwin) {
  1298.         if (($pagers[0] eq 'less') || ($pagers[0] eq '/usr/bin/less')) {
  1299.             unshift @pagers, '/usr/bin/less -isrR';
  1300.         }
  1301.     }
  1302.  
  1303.     unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER};
  1304.     
  1305.     return;   
  1306. }
  1307.  
  1308. #..........................................................................
  1309.  
  1310. sub page_module_file {
  1311.     my($self, @found) = @_;
  1312.  
  1313.     # Security note:
  1314.     # Don't ever just pass this off to anything like MSWin's "start.exe",
  1315.     # since we might be calling on a .pl file, and we wouldn't want that
  1316.     # to actually /execute/ the file that we just want to page thru!
  1317.     # Also a consideration if one were to use a web browser as a pager;
  1318.     # doing so could trigger the browser's MIME mapping for whatever
  1319.     # it thinks .pm/.pl/whatever is.  Probably just a (useless and
  1320.     # annoying) "Save as..." dialog, but potentially executing the file
  1321.     # in question -- particularly in the case of MSIE and it's, ahem,
  1322.     # occasionally hazy distinction between OS-local extension
  1323.     # associations, and browser-specific MIME mappings.
  1324.  
  1325.     if ($self->{'output_to_stdout'}) {
  1326.         $self->aside("Sending unpaged output to STDOUT.\n");
  1327.     local $_;
  1328.     my $any_error = 0;
  1329.         foreach my $output (@found) {
  1330.         unless( open(TMP, "<", $output) ) {    # XXX 5.6ism
  1331.           warn("Can't open $output: $!");
  1332.           $any_error = 1;
  1333.           next;
  1334.         }
  1335.         while (<TMP>) {
  1336.             print or die "Can't print to stdout: $!";
  1337.         } 
  1338.         close TMP  or die "Can't close while $output: $!";
  1339.         $self->unlink_if_temp_file($output);
  1340.     }
  1341.     return $any_error; # successful
  1342.     }
  1343.  
  1344.     foreach my $pager ( $self->pagers ) {
  1345.         $self->aside("About to try calling $pager @found\n");
  1346.         if (system($pager, @found) == 0) {
  1347.             $self->aside("Yay, it worked.\n");
  1348.             return 0;
  1349.         }
  1350.         $self->aside("That didn't work.\n");
  1351.         
  1352.         # Odd -- when it fails, under Win32, this seems to neither
  1353.         #  return with a fail nor return with a success!!
  1354.         #  That's discouraging!
  1355.     }
  1356.  
  1357.     $self->aside(
  1358.       sprintf "Can't manage to find a way to page [%s] via pagers [%s]\n",
  1359.       join(' ', @found),
  1360.       join(' ', $self->pagers),
  1361.     );
  1362.     
  1363.     if (IS_VMS) { 
  1364.         DEBUG > 1 and print "Bailing out in a VMSish way.\n";
  1365.         eval q{
  1366.             use vmsish qw(status exit); 
  1367.             exit $?;
  1368.             1;
  1369.         } or die;
  1370.     }
  1371.     
  1372.     return 1;
  1373.       # i.e., an UNSUCCESSFUL return value!
  1374. }
  1375.  
  1376. #..........................................................................
  1377.  
  1378. sub check_file {
  1379.     my($self, $dir, $file) = @_;
  1380.     
  1381.     unless( ref $self ) {
  1382.       # Should never get called:
  1383.       $Carp::Verbose = 1;
  1384.       require Carp;
  1385.       Carp::croak( join '',
  1386.         "Crazy ", __PACKAGE__, " error:\n",
  1387.         "check_file must be an object_method!\n",
  1388.         "Aborting"
  1389.       );
  1390.     }
  1391.     
  1392.     if(length $dir and not -d $dir) {
  1393.       DEBUG > 3 and print "  No dir $dir -- skipping.\n";
  1394.       return "";
  1395.     }
  1396.     
  1397.     if ($self->opt_m) {
  1398.     return $self->minus_f_nocase($dir,$file);
  1399.     }
  1400.     
  1401.     else {
  1402.     my $path = $self->minus_f_nocase($dir,$file);
  1403.         if( length $path and $self->containspod($path) ) {
  1404.             DEBUG > 3 and print
  1405.               "  The file $path indeed looks promising!\n";
  1406.             return $path;
  1407.         }
  1408.     }
  1409.     DEBUG > 3 and print "  No good: $file in $dir\n";
  1410.     
  1411.     return "";
  1412. }
  1413.  
  1414. #..........................................................................
  1415.  
  1416. sub containspod {
  1417.     my($self, $file, $readit) = @_;
  1418.     return 1 if !$readit && $file =~ /\.pod\z/i;
  1419.  
  1420.  
  1421.     #  Under cygwin the /usr/bin/perl is legal executable, but
  1422.     #  you cannot open a file with that name. It must be spelled
  1423.     #  out as "/usr/bin/perl.exe".
  1424.     #
  1425.     #  The following if-case under cygwin prevents error
  1426.     #
  1427.     #     $ perldoc perl
  1428.     #     Cannot open /usr/bin/perl: no such file or directory
  1429.     #
  1430.     #  This would work though
  1431.     #
  1432.     #     $ perldoc perl.pod
  1433.  
  1434.     if ( IS_Cygwin  and  -x $file  and  -f "$file.exe" )
  1435.     {
  1436.         warn "Cygwin $file.exe search skipped\n"  if DEBUG or $self->opt_v;
  1437.         return 0;
  1438.     }
  1439.  
  1440.     local($_);
  1441.     open(TEST,"<", $file)     or die "Can't open $file: $!";   # XXX 5.6ism
  1442.     while (<TEST>) {
  1443.     if (/^=head/) {
  1444.         close(TEST)     or die "Can't close $file: $!";
  1445.         return 1;
  1446.     }
  1447.     }
  1448.     close(TEST)         or die "Can't close $file: $!";
  1449.     return 0;
  1450. }
  1451.  
  1452. #..........................................................................
  1453.  
  1454. sub maybe_diddle_INC {
  1455.   my $self = shift;
  1456.   
  1457.   # Does this look like a module or extension directory?
  1458.   
  1459.   if (-f "Makefile.PL") {
  1460.  
  1461.     # Add "." and "lib" to @INC (if they exist)
  1462.     eval q{ use lib qw(. lib); 1; } or die;
  1463.  
  1464.     # don't add if superuser
  1465.     if ($< && $> && -f "blib") {   # don't be looking too hard now!
  1466.       eval q{ use blib; 1 };
  1467.       warn $@ if $@ && $self->opt_v;
  1468.     }
  1469.   }
  1470.   
  1471.   return;
  1472. }
  1473.  
  1474. #..........................................................................
  1475.  
  1476. sub new_output_file {
  1477.   my $self = shift;
  1478.   my $outspec = $self->opt_d;  # Yes, -d overrides all else!
  1479.                                # So don't call this twice per format-job!
  1480.   
  1481.   return $self->new_tempfile(@_) unless defined $outspec and length $outspec;
  1482.  
  1483.   # Otherwise open a write-handle on opt_d!f
  1484.  
  1485.   my $fh;
  1486.   # If we are running before perl5.6.0, we can't autovivify
  1487.   if ($] < 5.006) {
  1488.     require Symbol;
  1489.     $fh = Symbol::gensym();
  1490.   }
  1491.   DEBUG > 3 and print "About to try writing to specified output file $outspec\n";
  1492.   die "Can't write-open $outspec: $!"
  1493.    unless open($fh, ">", $outspec); # XXX 5.6ism
  1494.   
  1495.   DEBUG > 3 and print "Successfully opened $outspec\n";
  1496.   binmode($fh) if $self->{'output_is_binary'};
  1497.   return($fh, $outspec);
  1498. }
  1499.  
  1500. #..........................................................................
  1501.  
  1502. sub useful_filename_bit {
  1503.   # This tries to provide a meaningful bit of text to do with the query,
  1504.   # such as can be used in naming the file -- since if we're going to be
  1505.   # opening windows on temp files (as a "pager" may well do!) then it's
  1506.   # better if the temp file's name (which may well be used as the window
  1507.   # title) isn't ALL just random garbage!
  1508.   # In other words "perldoc_LWPSimple_2371981429" is a better temp file
  1509.   # name than "perldoc_2371981429".  So this routine is what tries to
  1510.   # provide the "LWPSimple" bit.
  1511.   #
  1512.   my $self = shift;
  1513.   my $pages = $self->{'pages'} || return undef;
  1514.   return undef unless @$pages;
  1515.   
  1516.   my $chunk = $pages->[0];
  1517.   return undef unless defined $chunk;
  1518.   $chunk =~ s/:://g;
  1519.   $chunk =~ s/\.\w+$//g; # strip any extension
  1520.   if( $chunk =~ m/([^\#\\:\/\$]+)$/s ) { # get basename, if it's a file
  1521.     $chunk = $1;
  1522.   } else {
  1523.     return undef;
  1524.   }
  1525.   $chunk =~ s/[^a-zA-Z0-9]+//g; # leave ONLY a-zA-Z0-9 things!
  1526.   $chunk = substr($chunk, -10) if length($chunk) > 10;
  1527.   return $chunk;
  1528. }
  1529.  
  1530. #..........................................................................
  1531.  
  1532. sub new_tempfile {    # $self->new_tempfile( [$suffix, [$infix] ] )
  1533.   my $self = shift;
  1534.  
  1535.   ++$Temp_Files_Created;
  1536.  
  1537.   if( IS_MSWin32 ) {
  1538.     my @out = $self->MSWin_perldoc_tempfile(@_);
  1539.     return @out if @out;
  1540.     # otherwise fall thru to the normal stuff below...
  1541.   }
  1542.   
  1543.   require File::Temp;
  1544.   return File::Temp::tempfile(UNLINK => 1);
  1545. }
  1546.  
  1547. #..........................................................................
  1548.  
  1549. sub page {  # apply a pager to the output file
  1550.     my ($self, $output, $output_to_stdout, @pagers) = @_;
  1551.     if ($output_to_stdout) {
  1552.         $self->aside("Sending unpaged output to STDOUT.\n");
  1553.     open(TMP, "<", $output)  or  die "Can't open $output: $!"; # XXX 5.6ism
  1554.     local $_;
  1555.     while (<TMP>) {
  1556.         print or die "Can't print to stdout: $!";
  1557.     } 
  1558.     close TMP  or die "Can't close while $output: $!";
  1559.     $self->unlink_if_temp_file($output);
  1560.     } else {
  1561.         # On VMS, quoting prevents logical expansion, and temp files with no
  1562.         # extension get the wrong default extension (such as .LIS for TYPE)
  1563.  
  1564.         $output = VMS::Filespec::rmsexpand($output, '.') if IS_VMS;
  1565.  
  1566.         $output =~ s{/}{\\}g if IS_MSWin32 || IS_Dos;
  1567.           # Altho "/" under MSWin is in theory good as a pathsep,
  1568.           #  many many corners of the OS don't like it.  So we
  1569.           #  have to force it to be "\" to make everyone happy.
  1570.  
  1571.         foreach my $pager (@pagers) {
  1572.             $self->aside("About to try calling $pager $output\n");
  1573.             if (IS_VMS) {
  1574.                 last if system("$pager $output") == 0;
  1575.             } else {
  1576.             last if system("$pager \"$output\"") == 0;
  1577.             }
  1578.     }
  1579.     }
  1580.     return;
  1581. }
  1582.  
  1583. #..........................................................................
  1584.  
  1585. sub searchfor {
  1586.     my($self, $recurse,$s,@dirs) = @_;
  1587.     $s =~ s!::!/!g;
  1588.     $s = VMS::Filespec::unixify($s) if IS_VMS;
  1589.     return $s if -f $s && $self->containspod($s);
  1590.     $self->aside( "Looking for $s in @dirs\n" );
  1591.     my $ret;
  1592.     my $i;
  1593.     my $dir;
  1594.     $self->{'target'} = (splitdir $s)[-1];  # XXX: why not use File::Basename?
  1595.     for ($i=0; $i<@dirs; $i++) {
  1596.     $dir = $dirs[$i];
  1597.     next unless -d $dir;
  1598.     ($dir = VMS::Filespec::unixpath($dir)) =~ s!/\z!! if IS_VMS;
  1599.     if (       (! $self->opt_m && ( $ret = $self->check_file($dir,"$s.pod")))
  1600.         or ( $ret = $self->check_file($dir,"$s.pm"))
  1601.         or ( $ret = $self->check_file($dir,$s))
  1602.         or ( IS_VMS and
  1603.              $ret = $self->check_file($dir,"$s.com"))
  1604.         or ( IS_OS2 and
  1605.              $ret = $self->check_file($dir,"$s.cmd"))
  1606.         or ( (IS_MSWin32 or IS_Dos or IS_OS2) and
  1607.              $ret = $self->check_file($dir,"$s.bat"))
  1608.         or ( $ret = $self->check_file("$dir/pod","$s.pod"))
  1609.         or ( $ret = $self->check_file("$dir/pod",$s))
  1610.         or ( $ret = $self->check_file("$dir/pods","$s.pod"))
  1611.         or ( $ret = $self->check_file("$dir/pods",$s))
  1612.     ) {
  1613.         DEBUG > 1 and print "  Found $ret\n";
  1614.         return $ret;
  1615.     }
  1616.  
  1617.     if ($recurse) {
  1618.         opendir(D,$dir)    or die "Can't opendir $dir: $!";
  1619.         my @newdirs = map catfile($dir, $_), grep {
  1620.         not /^\.\.?\z/s and
  1621.         not /^auto\z/s  and   # save time! don't search auto dirs
  1622.         -d  catfile($dir, $_)
  1623.         } readdir D;
  1624.         closedir(D)        or die "Can't closedir $dir: $!";
  1625.         next unless @newdirs;
  1626.         # what a wicked map!
  1627.         @newdirs = map((s/\.dir\z//,$_)[1],@newdirs) if IS_VMS;
  1628.         $self->aside( "Also looking in @newdirs\n" );
  1629.         push(@dirs,@newdirs);
  1630.     }
  1631.     }
  1632.     return ();
  1633. }
  1634.  
  1635. #..........................................................................
  1636. {
  1637.   my $already_asserted;
  1638.   sub assert_closing_stdout {
  1639.     my $self = shift;
  1640.  
  1641.     return if $already_asserted;
  1642.  
  1643.     eval  q~ END { close(STDOUT) || die "Can't close STDOUT: $!" } ~;
  1644.      # What for? to let the pager know that nothing more will come?
  1645.   
  1646.     die $@ if $@;
  1647.     $already_asserted = 1;
  1648.     return;
  1649.   }
  1650. }
  1651.  
  1652. #..........................................................................
  1653.  
  1654. sub tweak_found_pathnames {
  1655.   my($self, $found) = @_;
  1656.   if (IS_MSWin32) {
  1657.     foreach (@$found) { s,/,\\,g }
  1658.   }
  1659.   return;
  1660. }
  1661.  
  1662. #..........................................................................
  1663. #    :    :    :    :    :    :    :    :    :
  1664. #..........................................................................
  1665.  
  1666. sub am_taint_checking {
  1667.     my $self = shift;
  1668.     die "NO ENVIRONMENT?!?!" unless keys %ENV; # reset iterator along the way
  1669.     my($k,$v) = each %ENV;
  1670.     return is_tainted($v);  
  1671. }
  1672.  
  1673. #..........................................................................
  1674.  
  1675. sub is_tainted { # just a function
  1676.     my $arg  = shift;
  1677.     my $nada = substr($arg, 0, 0);  # zero-length!
  1678.     local $@;  # preserve the caller's version of $@
  1679.     eval { eval "# $nada" };
  1680.     return length($@) != 0;
  1681. }
  1682.  
  1683. #..........................................................................
  1684.  
  1685. sub drop_privs_maybe {
  1686.     my $self = shift;
  1687.     
  1688.     # Attempt to drop privs if we should be tainting and aren't
  1689.     if (!(IS_VMS || IS_MSWin32 || IS_Dos
  1690.           || IS_OS2
  1691.          )
  1692.         && ($> == 0 || $< == 0)
  1693.         && !$self->am_taint_checking()
  1694.     ) {
  1695.         my $id = eval { getpwnam("nobody") };
  1696.         $id = eval { getpwnam("nouser") } unless defined $id;
  1697.         $id = -2 unless defined $id;
  1698.             #
  1699.             # According to Stevens' APUE and various
  1700.             # (BSD, Solaris, HP-UX) man pages, setting
  1701.             # the real uid first and effective uid second
  1702.             # is the way to go if one wants to drop privileges,
  1703.             # because if one changes into an effective uid of
  1704.             # non-zero, one cannot change the real uid any more.
  1705.             #
  1706.             # Actually, it gets even messier.  There is
  1707.             # a third uid, called the saved uid, and as
  1708.             # long as that is zero, one can get back to
  1709.             # uid of zero.  Setting the real-effective *twice*
  1710.             # helps in *most* systems (FreeBSD and Solaris)
  1711.             # but apparently in HP-UX even this doesn't help:
  1712.             # the saved uid stays zero (apparently the only way
  1713.             # in HP-UX to change saved uid is to call setuid()
  1714.             # when the effective uid is zero).
  1715.             #
  1716.         eval {
  1717.             $< = $id; # real uid
  1718.             $> = $id; # effective uid
  1719.             $< = $id; # real uid
  1720.             $> = $id; # effective uid
  1721.         };
  1722.         if( !$@ && $< && $> ) {
  1723.           DEBUG and print "OK, I dropped privileges.\n";
  1724.         } elsif( $self->opt_U ) {
  1725.           DEBUG and print "Couldn't drop privileges, but in -U mode, so feh."
  1726.         } else {
  1727.           DEBUG and print "Hm, couldn't drop privileges.  Ah well.\n";
  1728.           # We used to die here; but that seemed pointless.
  1729.         }
  1730.     }
  1731.     return;
  1732. }
  1733.  
  1734. #..........................................................................
  1735.  
  1736. 1;
  1737.  
  1738. __END__
  1739.  
  1740. # See "perldoc perldoc" for basic details.
  1741. #
  1742. # Perldoc -- look up a piece of documentation in .pod format that
  1743. # is embedded in the perl installation tree.
  1744. # 
  1745. #~~~~~~
  1746. #
  1747. # See ChangeLog in CPAN dist for Pod::Perldoc for later notes.
  1748. #
  1749. # Version 3.01: Sun Nov 10 21:38:09 MST 2002
  1750. #       Sean M. Burke <sburke@cpan.org>
  1751. #       Massive refactoring and code-tidying.
  1752. #       Now it's a module(-family)!
  1753. #       Formatter-specific stuff pulled out into Pod::Perldoc::To(Whatever).pm
  1754. #       Added -T, -d, -o, -M, -w.
  1755. #       Added some improved MSWin funk.
  1756. #
  1757. #~~~~~~
  1758. #
  1759. # Version 2.05: Sat Oct 12 16:09:00 CEST 2002
  1760. #    Hugo van der Sanden <hv@crypt.org>
  1761. #    Made -U the default, based on patch from Simon Cozens
  1762. # Version 2.04: Sun Aug 18 13:27:12 BST 2002
  1763. #    Randy W. Sims <RandyS@ThePierianSpring.org>
  1764. #    allow -n to enable nroff under Win32
  1765. # Version 2.03: Sun Apr 23 16:56:34 BST 2000
  1766. #    Hugo van der Sanden <hv@crypt.org>
  1767. #    don't die when 'use blib' fails
  1768. # Version 2.02: Mon Mar 13 18:03:04 MST 2000
  1769. #       Tom Christiansen <tchrist@perl.com>
  1770. #    Added -U insecurity option
  1771. # Version 2.01: Sat Mar 11 15:22:33 MST 2000 
  1772. #       Tom Christiansen <tchrist@perl.com>, querulously.
  1773. #       Security and correctness patches.
  1774. #       What a twisted bit of distasteful spaghetti code.
  1775. # Version 2.0: ????
  1776. #
  1777. #~~~~~~
  1778. #
  1779. # Version 1.15: Tue Aug 24 01:50:20 EST 1999
  1780. #       Charles Wilson <cwilson@ece.gatech.edu>
  1781. #    changed /pod/ directory to /pods/ for cygwin
  1782. #         to support cygwin/win32
  1783. # Version 1.14: Wed Jul 15 01:50:20 EST 1998
  1784. #       Robin Barker <rmb1@cise.npl.co.uk>
  1785. #    -strict, -w cleanups
  1786. # Version 1.13: Fri Feb 27 16:20:50 EST 1997
  1787. #       Gurusamy Sarathy <gsar@activestate.com>
  1788. #    -doc tweaks for -F and -X options
  1789. # Version 1.12: Sat Apr 12 22:41:09 EST 1997
  1790. #       Gurusamy Sarathy <gsar@activestate.com>
  1791. #    -various fixes for win32
  1792. # Version 1.11: Tue Dec 26 09:54:33 EST 1995
  1793. #       Kenneth Albanowski <kjahds@kjahds.com>
  1794. #   -added Charles Bailey's further VMS patches, and -u switch
  1795. #   -added -t switch, with pod2text support
  1796. #
  1797. # Version 1.10: Thu Nov  9 07:23:47 EST 1995
  1798. #        Kenneth Albanowski <kjahds@kjahds.com>
  1799. #    -added VMS support
  1800. #    -added better error recognition (on no found pages, just exit. On
  1801. #     missing nroff/pod2man, just display raw pod.)
  1802. #    -added recursive/case-insensitive matching (thanks, Andreas). This
  1803. #     slows things down a bit, unfortunately. Give a precise name, and
  1804. #     it'll run faster.
  1805. #
  1806. # Version 1.01:    Tue May 30 14:47:34 EDT 1995
  1807. #        Andy Dougherty  <doughera@lafcol.lafayette.edu>
  1808. #   -added pod documentation.
  1809. #   -added PATH searching.
  1810. #   -added searching pod/ subdirectory (mainly to pick up perlfunc.pod
  1811. #    and friends.
  1812. #
  1813. #~~~~~~~
  1814. #
  1815. # TODO:
  1816. #
  1817. #    Cache the directories read during sloppy match
  1818. #       (To disk, or just in-memory?)
  1819. #
  1820. #       Backport this to perl 5.005?
  1821. #
  1822. #       Implement at least part of the "perlman" interface described
  1823. #       in Programming Perl 3e?
  1824.